Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue56/Splat/shapes.pas

Pascal/Delphi Source File | 2000-01-28 | 15.3 KB | 559 lines

unit Shapes;

// Splat.
// Shapes and the shape list.
// To add new shapes, inherit from TShape, and call RegisterShapes.
//
// Copyright ⌐ 2000 Tempest Software, Inc.

interface

uses Windows, SysUtils, Classes, Forms, Graphics, Types, Contnrs;

type
  TShape = class;
  TShapeClass = class of TShape;

  // Maintain a list of TShape-descendent objects.
  TShapeList = class(TObjectList)
  private
    fHeight, fWidth: NaturalInt;  // screen size
    function GetShape(Index: NaturalInt): TShape;
  public
    class function AnyShapeClass: TShapeClass;
    constructor Create(Width: NaturalInt = 0; Height: NaturalInt = 0);

    // Create a random shape and add it to the list.
    procedure AddShape(X, Y: NaturalInt);

    // Add the Help text to the center of the screen.
    procedure AddHelp;

    // Draw all the shapes on the canvas.
    procedure Draw(Canvas: TCanvas);

    // Iterate the next generation of shapes.
    procedure NextGeneration;

    // Get the shapes in the list.
    property Shapes[Index: NaturalInt]: TShape read GetShape; default;

    property Height: NaturalInt read fHeight;
    property Width: NaturalInt read fWidth;
  end;

  // Abstract base class for all shapes. Maintain the position of the
  // shape's center, size, and color. Each generation, fade the color
  // and move the shape. When the color becomes black, or when the shape
  // moves off the screen, the list deletes it.
  TShape = class
  private
    fColor: TColor;             // Color of shape
    fDelta: TPoint;             // Position change for each generation
    fPosition: TPoint;          // Center of shape
    fSize: TSize;
  protected
    constructor Create(Position: TPoint); virtual;
    // Randomly change the shape's color. The default is to fade towards black.
    procedure ChangeColor; virtual;
    // Draw this shape on the canvas, at the current position,
    // using the current color. Derived classes must override this method.
    procedure Draw(Canvas: TCanvas); virtual; abstract;
    // Randomly change the size of the shape.
    procedure ChangeSize; virtual;
    // Generate a random position Delta, which can be positive or negative.
    procedure GenerateDelta; virtual;

    // Get the shape's bounding box.
    procedure BoundingBox(var Rect: TRect); virtual;
    function GetBottom: Integer; virtual;
    function GetLeft: Integer; virtual;
    function GetRight: Integer; virtual;
    function GetTop: Integer; virtual;

    // Return True if the color is not black and if the shape's bounding
    // box is still visible on the screen.
    function IsVisible(Width, Height: NaturalInt): Boolean; virtual;
    // Move the shape's position by its delta.
    procedure Move; virtual;

    // Generate the next generation by fading the color.
    procedure NextGeneration(Width, Height: NaturalInt); virtual;

  public
    property Color: TColor read fColor write fColor;
    property Delta: TPoint read fDelta write fDelta;
    property Position: TPoint read fPosition write fPosition;
    property XPosition: Integer read fPosition.X write fPosition.X;
    property YPosition: Integer read fPosition.Y write fPosition.Y;
    property Size: TSize read fSize write fSize;
    property XSize: Integer read fSize.CX write fSize.CX;
    property YSize: Integer read fSize.CY write fSize.CY;

    property Left: Integer read GetLeft;
    property Right: Integer read GetRight;
    property Top: Integer read GetTop;
    property Bottom: Integer read GetBottom;
  end;

  // The THelp shape tells the user how to end the program.
  // The TShapeList always starts with a THelp object in the list.
  // The help message gets smaller with each generation.
  THelp = class(TShape)
  private
    fFontHeight: Single;
  protected
    function IsVisible(Width, Height: NaturalInt): Boolean; override;
  public
    constructor Create(Position: TPoint); override;
    procedure Draw(Canvas: TCanvas); override;
    procedure ChangeSize; override;
    procedure Move; override;
    property FontHeight: Single read fFontHeight write fFontHeight;
  end;

  // Elliptical shape.
  TEllipse = class(TShape)
  public
    procedure Draw(Canvas: TCanvas); override;
  end;

  // Regular polygon with 3-12 vertices. The polygon starts small
  // and grows with each generation.
  TPolygon = class(TShape)
  private
    fNumVertices: PositiveInt;
  public
    constructor Create(Position: TPoint); override;
    procedure Draw(Canvas: TCanvas); override;
    property NumVertices: PositiveInt read fNumVertices;
  end;

  // Make sure there are plenty of small, simple shapes, so
  // create distinct classes for triangles and rectangles.
  // Keep life simple by creating only equilateral triangles.
  TTriangle = class(TPolygon)
  public
    procedure AfterConstruction; override;
  end;
  // Use a distinct rectangle class so we can have shapes other
  // than squares (especially since squares are drawn so they
  // look like lozenges).
  TRectangle = class(TShape)
  public
    constructor Create(Position: TPoint); override;
    procedure Draw(Canvas: TCanvas); override;
  end;

  // Regular star. Just like a polygon, but with extra vertices
  // interpolated between the usual vertices. The extra vertices
  // are at a radius of 1/2 the polygon's radius. The result is
  // a regular star.
  TStar = class(TPolygon)
  public
    procedure Draw(Canvas: TCanvas); override;
    constructor Create(Position: TPoint); override;
  end;

procedure RegisterShapes(Shapes: array of TShapeClass);

const
  DeltaColor = 3;
  DeltaDimension = 3;
  InitialDimension = 10;
  DeltaPosition = 5;
  BackgroundColor = COLORREF(clBlack);

implementation

uses Math;

// Keep track of all shape classes, so choose one at random for creating
// new shapes.
var
  ShapeClassList: array of TShapeClass;

// Register new shape classes by adding them to the ShapeClassList.
procedure RegisterShapes(Shapes: array of TShapeClass);
var
  I: Integer;
begin
  SetLength(ShapeClassList, Length(ShapeClassList) + Length(Shapes));
  for I := Low(Shapes) to High(Shapes) do
    ShapeClassList[Length(ShapeClassList)-Length(Shapes)+I] := Shapes[I];
end;

{ TShapeList }

// Add the THelp message shape.
procedure TShapeList.AddHelp;
begin
  Insert(0, THelp.Create(Point(Width div 2, Height div 2)));
end;

// Add a random shape on top of other shapes.
procedure TShapeList.AddShape(X, Y: NaturalInt);
var
  ShapeClass: TShapeClass;
  Shape: TShape;
begin
  ShapeClass := AnyShapeClass;
  Shape := ShapeClass.Create(Point(X, Y));
  Add(Shape);
end;

// Return a random shape class, chosen from ShapeClassList.
class function TShapeList.AnyShapeClass: TShapeClass;
begin
  if Length(ShapeClassList) = 0 then
    Result := THelp
  else
    Result := ShapeClassList[Random(Length(ShapeClassList))];
end;

// Create a new shape list. Remember the screen size.
constructor TShapeList.Create(Width, Height: NaturalInt);
begin
  inherited;
  if Width = 0 then
    fWidth := Screen.Width
  else
    fWidth := Width;
  if Height = 0 then
    fHeight := Screen.Height
  else
    fHeight := Height;
end;

// Draw all the shapes on the canvas.
procedure TShapeList.Draw(Canvas: TCanvas);
var
  I: Integer;
begin
  for I := 0 to Count-1 do
    Shapes[I].Draw(Canvas);
end;

// Get a shape from the list.
function TShapeList.GetShape(Index: NaturalInt): TShape;
begin
  Result := Items[Index] as TShape;
end;

// Create the next generation of shapes. If any shape becomes
// invisible, delete it from the list. Count down so deletion
// does not affect the list iteration.
procedure TShapeList.NextGeneration;
var
  I: Integer;
begin
  for I := Count-1 downto 0 do
  begin
    Shapes[I].NextGeneration(Width, Height);
    if not Shapes[I].IsVisible(Width, Height) then
      Delete(I);
  end;
end;

// Map Hue-Saturation-Value to Red-Green-Blue colors.
type
  THue = 0..359;
function HsvToRgb(Hue: THue; Saturation, Value: Byte): TColor;
resourcestring
  sCannotHappen = 'HsvToRgb: Cannot happen, Hue = %d';
var
  P, Q, R: Byte;
  F: Single;
begin
  if Saturation = 0 then
    Result := RGB(Value, Value, Value)
  else
  begin
    F := Frac(Hue / 60);
    P := Value * (255 - Saturation) div 256;
    Q := Round(Value * (255 - Saturation * F)) div 256;
    R := Round(Value * (255 - Saturation * (1 - F))) div 256;
    case Hue div 60 of
    0: Result := RGB(Value, R, P);
    1: Result := RGB(Q, Value, P);
    2: Result := RGB(P, Value, R);
    3: Result := RGB(P, Q, Value);
    4: Result := RGB(R, P, Value);
    5: Result := RGB(Value, P, Q);
    else
      raise Exception.CreateFmt(sCannotHappen, [Hue]);
    end;
  end;
end;

// Pick a random color by choosing a random hue and a random
// saturation. Keep the full value of 255, to avoid starting
// with dark colors.
function RandomColor: TColor;
begin
  Result := HsvToRgb(Random(360), 255, 255);
end;

{ TShape }

// Get the shape's bounding box and store it in Rect.
procedure TShape.BoundingBox(var Rect: TRect);
begin
  Rect.Left   := Left;
  Rect.Right  := Right;
  Rect.Top    := Top;
  Rect.Bottom := Bottom;
end;

// Change the shape's color by fading slowly to black.
procedure TShape.ChangeColor;
var
  Red, Green, Blue: Integer;
begin
  Red := GetRValue(Color) - Random(DeltaColor);
  if Red < 0 then
    Red := 0;
  Green := GetGValue(Color) - Random(DeltaColor);
  if Green < 0 then
    Green := 0;
  Blue := GetBValue(Color) - Random(DeltaColor);
  if Blue < 0 then
    Blue := 0;
  Color := RGB(Red, Green, Blue);
end;

// Increase the shape's size slightly.
procedure TShape.ChangeSize;
begin
  XSize := XSize + Random(DeltaDimension);
  YSize := YSize + Random(DeltaDimension);
end;

// Create the shape with a random color.
constructor TShape.Create(Position: TPoint);
begin
  inherited Create;
  fPosition := Position;
  fColor := RandomColor;
  XSize := InitialDimension;
  YSize := InitialDimension;
  GenerateDelta;
end;

// Generate a random position delta, which can be positive or negative.
procedure TShape.GenerateDelta;
begin
  fDelta.X := Random(DeltaPosition * 2) - DeltaPosition;
  fDelta.Y := Random(DeltaPosition * 2) - DeltaPosition;
end;

// Return the bottom coordinate, assuming a symmetrical shape.
function TShape.GetBottom: Integer;
begin
  Result := Top + YSize;
end;

// Return the left coordinate, assuming a symmetrical shape.
function TShape.GetLeft: Integer;
begin
  Result := XPosition - XSize div 2;
end;

// Return the right coordinate, assuming a symmetrical shape.
function TShape.GetRight: Integer;
begin
  Result := Left + XSize;
end;

// Return the top coordinate, assuming a symmetrical shape.
function TShape.GetTop: Integer;
begin
  Result := YPosition - YSize div 2;
end;

// Return True if the shape is invisible: off the screen or completely black.
function TShape.IsVisible(Width, Height: NaturalInt): Boolean;
begin
  Result := (COLORREF(Color) <> BackgroundColor) and
            (Right >= 0) and
            (Bottom >= 0) and
            (Left <= Width-1) and
            (Top <= Height-1);
end;

// Move the shape for a generation.
procedure TShape.Move;
begin
  XPosition := XPosition + Delta.X;
  YPosition := YPosition + Delta.Y;
end;

// Each generation, move, grow, and recolor the shape.
procedure TShape.NextGeneration(Width, Height: NaturalInt);
begin
  Move;
  ChangeColor;
  ChangeSize;
end;

{ TEllipse }

procedure TEllipse.Draw(Canvas: TCanvas);
begin
  Canvas.Brush.Color := Color;
  Canvas.Pen.Color := Color;
  Canvas.Ellipse(Position.X - XSize div 2, Position.Y - YSize,
                 Position.X + XSize, Position.Y + YSize);
end;

{ TPolygon }

const
  MinVertices = 3;
  MaxVertices = 12;

// The bounding box isn't always the smallest bounding box,
// but it's an adequate approximation.
constructor TPolygon.Create(Position: TPoint);
begin
  inherited;
  fNumVertices := Random(MaxVertices - MinVertices + 1) + MinVertices;
end;

procedure TPolygon.Draw(Canvas: TCanvas);
var
  I: Integer;
  Pt: TPoint;
  Points: array of TPoint;
  Angle: Single;
begin
  SetLength(Points, NumVertices);
  for I := Low(Points) to High(Points) do
  begin
    Angle := 2*Pi * I / Length(Points);
    Pt.X := Round(Position.X + XSize * Cos(Angle));
    Pt.Y := Round(Position.Y + YSize * Sin(Angle));
    Points[I] := Pt;
  end;
  Canvas.Pen.Color := Color;
  Canvas.Brush.Color := Color;
  Canvas.Polygon(Points);
end;


{ THelp }

constructor THelp.Create(Position: TPoint);
begin
  inherited;
  Color := clYellow;
  FontHeight := 48;
end;

// Display a help message, telling the user how to exit the program.
procedure THelp.Draw(Canvas: TCanvas);
resourcestring
  HelpMsg = 'Press ESC to end the program';
var
  X, Y: Integer;
begin
  Canvas.Font.Color := Color;
  Canvas.Font.Name := 'Arial';
  Canvas.Font.Height := Round(FontHeight);
  Canvas.Font.Style := [fsBold];
  X := Position.X - Canvas.TextWidth(HelpMsg) div 2;
  Y := Position.Y - Canvas.TextHeight(HelpMsg) div 2;
  Canvas.TextOut(X, Y, HelpMsg);
end;

// The help text gets smaller with each generation. When the font size
// reaches zero, the shape becomes invisible. (Note that Windows does not
// allow a font height of zero pixels.)
function THelp.IsVisible(Width, Height: NaturalInt): Boolean;
begin
  Result := inherited IsVisible(Width, Height) and (FontHeight > 1);
end;

// The help text gets slowly smaller. Font heights are mapped to integers,
// but using 0.5 each generation slows down the speed at which the text
// becomes invisible.
procedure THelp.ChangeSize;
begin
  FontHeight := FontHeight - 0.5;
end;

// The help message doesn't move.
procedure THelp.Move;
begin
end;

{ TTriangle }

procedure TTriangle.AfterConstruction;
begin
  inherited;
  fNumVertices := 3;
end;

{ TRectangle }

// Create the rectangle with a random, but nonzero size.
constructor TRectangle.Create(Position: TPoint);
begin
  inherited;
  YSize := Random(InitialDimension) + 1;
  XSize := Random(InitialDimension) + 1;
end;

procedure TRectangle.Draw(Canvas: TCanvas);
var
  Rect: TRect;
begin
  Canvas.Brush.Color := Color;
  BoundingBox(Rect);
  Canvas.FillRect(Rect);
end;


{ TStar }

const
  MinStarVertices = 4;
  MaxStarVertices = 8;

// For simplicity, a star has more restricted range of number of vertices.
constructor TStar.Create(Position: TPoint);
begin
  inherited;
  fNumVertices := Random(MaxStarVertices - MinStarVertices + 1) + MinStarVertices;
end;

procedure TStar.Draw(Canvas: TCanvas);
var
  I: Integer;
  Pt: TPoint;
  Points: array of TPoint;
  Angle: Single;
  Divisor: 1..2;
begin
  SetLength(Points, NumVertices * 2);
  Divisor := 1;
  for I := Low(Points) to High(Points) do
  begin
    Angle := 2*Pi * I / Length(Points);
    Pt.X := Round(Position.X + XSize / Divisor * Cos(Angle));
    Pt.Y := Round(Position.Y + YSize / Divisor * Sin(Angle));
    Points[I] := Pt;
    Divisor := 3 - Divisor;    // Change 1 to 2 and 2 to 1.
  end;
  Canvas.Pen.Color := Color;
  Canvas.Brush.Color := Color;
  Canvas.Polygon(Points);
end;

initialization
  // To create lots of polygons, register TPolygon more than once.
  RegisterShapes([TEllipse, TTriangle, TRectangle, TStar,
                  TPolygon, TPolygon, TPolygon]);
end.